home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgramD2.iso / Borland / Borland Pascal with Objects 7.0 / HEAPSPY.ZIP / HWDLGS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-10-27  |  9.8 KB  |  378 lines
  1. {$A-,B-,E-,F-,G+,I-,K-,N-,O-,P-,Q-,R-,S-,T+,V-,W-,X+}
  2.  
  3. {**********************************************}
  4. {                                              }
  5. {   HeapSpy - HWDlgs Module                    }
  6. {   Copyright (c) 1992  Borland International  }
  7. {                                              }
  8. {**********************************************}
  9.  
  10. unit HWDlgs;
  11.  
  12. {$C MOVEABLE DEMANDLOAD DISCARDABLE}
  13.  
  14. interface
  15.  
  16. uses Wintypes, WinProcs, Objects, ODialogs, OWindows, BWCC, Strings,
  17.   ToolHelp, HWGlobal;
  18.  
  19. type
  20.   PModuleDlg = ^TmoduleDlg;
  21.   TModuleDlg = object(TBWCCDlg)
  22.     ModuleName: PChar;
  23.     LB: PListBox;
  24.     constructor Init(AParent: PWindowsObject; AID: PChar; AModuleName: PChar);
  25.     procedure SetupWindow; virtual;
  26.     procedure ListSel(var Msg: Tmessage);
  27.       virtual id_First + id_ModuleList;
  28.     procedure UnloadMod(var Msg: TMessage);
  29.       virtual id_First + 104;
  30.     procedure OK(var Msg: TMessage);
  31.       virtual id_First + id_OK;
  32.     procedure ModuleInfo(var Msg: TMessage);
  33.       virtual id_First + cm_Modinfo;
  34.     procedure Color(var Msg: TMessage);
  35.       virtual wm_First + wm_CtlColor;
  36.   end;
  37.  
  38.   PModuleInfo = ^TModuleInfo;
  39.   TModuleInfo = object(TBWCCDlg)
  40.     ModuleName: PChar;
  41.     Module: THandle;
  42.     Modl: TModuleEntry;
  43.     Globl: TGlobalEntry;
  44.     CodeSize, DataSize,ResourceSize,OtherSize: LongInt;
  45.     constructor Init(AParent: PWindowsObject; AID, AModuleName: PChar);
  46.     procedure SetupWindow; virtual;
  47.     procedure WMCtlColor(var Msg: TMessage);
  48.       virtual wm_First + wm_CtlColor;
  49.   end;
  50.  
  51.   PAbtDlg = ^TAbtDlg;
  52.   TAbtDlg = object(TBWCCDlg)
  53.     constructor Init(AParent: PWindowsObject; AnID: PChar);
  54.     procedure GetWindowClass(var WC: TWndClass); virtual;
  55.     function GetClassName: PChar; virtual;
  56.     procedure SetupWindow; virtual;
  57.   end;
  58.  
  59.   POptionDlg = ^TOptionDlg;
  60.   TOptionDlg = object(TBWCCDlg)
  61.     constructor Init(AParent: PWindowsObject; AnID: PChar);
  62.     procedure OK(var Msg: TMessage);
  63.       virtual id_First + id_OK;
  64.   end;
  65.  
  66.   PMemDlg = ^TMemDlg;
  67.   TMemDlg = object(TBWCCDlg)
  68.     procedure SetupWindow; virtual;
  69.   end;
  70.  
  71. implementation
  72.  
  73. constructor TOptionDlg.Init;
  74. var
  75.   I: Integer;
  76.   T: PWindowsObject;
  77. begin
  78.   inherited Init(APArent, AnID, menu_Options);
  79.   T := New(PCheckBox, InitResource(@Self, 101));
  80.   T := New(PCheckBox,InitResource(@Self, op_SpeedBar));
  81.   for I := 0 to 1 do
  82.     T := New(PRadioButton,InitResource(@Self,op_Vertical + I));
  83.   for I := 0 to 4 do
  84.     T := New(PRadioButton, InitResource(@Self,102 + I));
  85.   TransferBuffer := @Glbl;
  86. end;
  87.  
  88. procedure TOptionDlg.OK;
  89. var
  90.   Temp: array[0..10] of Char;
  91. begin
  92.   inherited OK(Msg);
  93.   Str(Word(Glbl.RebuildOnActivate), Temp);
  94.   WritePrivateProfileString(OptionsKey, RebuildKey, Temp, INIFile);
  95.   Str(Word(Glbl.UseSpeedBar), Temp);
  96.   WritePrivateProfileString(OptionsKey, SpeedBarKey, Temp, INIFile);
  97.   Str(DefaultSortOpt - cm_sbAddress, Temp);
  98.   WritePrivateProfileString(OptionsKey, SortOptKey, Temp, INIFile);
  99.   Str(TilingMethod - op_vertical, Temp);
  100.   WritePrivateProfileString(OptionsKey, WinTileKey, Temp, INIFile);
  101.   SendMessage(Application^.MainWindow^.HWindow, user_UpdateSpeed, 0, 0);
  102. end;
  103.  
  104. constructor TAbtDlg.Init;
  105. begin
  106.   inherited Init(APArent,AnID,0);
  107. end;
  108.  
  109. procedure TAbtDlg.GetWindowClass(var WC: TWndClass);
  110. begin
  111.   inherited GetWindowClass(WC);
  112. end;
  113.  
  114. function TAbtDlg.GetClassName: PChar;
  115. begin
  116.   GetClassName := 'BORDLG_ABT';
  117. end;
  118.  
  119. procedure TAbtDlg.SetupWindow;
  120. Var
  121.   M: TMemManInfo;
  122.   H: TSysHeapInfo;
  123.   temp: array[0..20] of Char;
  124.   PercentFree,UserFree: Word;
  125. begin
  126.   inherited SetupWindow;
  127.  
  128.   if (GetWinFlags and wf_Enhanced) <> 0 then
  129.     SendDlgItemMsg(ab_WinMode, wm_SetText, 0,
  130.       LongInt(PChar('386 Enhanced Mode')))
  131.   else
  132.     SendDlgItemMsg(ab_WinMode, wm_SetText, 0,
  133.       LongInt(PChar('Standard Mode')));
  134.  
  135.   Str(GetFreeSpace(0) div 1024,Temp);
  136.   Strcat(Temp,'K');
  137.   SendDlgItemMSg(ab_FreeMem, wm_SetText, 0, LongInt(@TEMP));
  138.  
  139.   H.dwSize := SizeOf(TSysHeapInfo);
  140.   SystemHeapInfo(@H);
  141.   if H.wUserFreePercent < H.wGDIFreePercent then
  142.     PercentFree := H.wUserFreePercent
  143.   else
  144.     PErcentFree := H.wGDIFreePercent;
  145.   Str(PercentFree,Temp);
  146.   StrCat(Temp,' %');
  147.   SendDlgItemMsg(ab_ResPct, wm_SetText, 0, LongInt(@TEMP));
  148. end;
  149.  
  150. constructor TModuleDlg.Init;
  151. begin
  152.   inherited Init(Aparent,AID,MENU_HEAP_SELMOD);
  153.   ModuleName := AModuleName;
  154.   ModuleName[0] := #0;
  155.   New(LB,InitResource(@Self,id_ModuleList));
  156. end;
  157.  
  158.  
  159. procedure TModuleDlg.ListSel;
  160. begin
  161.  with Msg do
  162.    if lParamHi = LBN_DBLCLK then
  163.    begin
  164.      LB^.GetSelString(ModuleName,8);
  165.      EndDlg(id_OK);
  166.    end;
  167. end;
  168.  
  169. procedure TModuleDlg.UnloadMod;
  170. var
  171.   ModID: array[0..8] of Char;
  172.   MBStr: array[0..100] of Char;
  173.   MBInfo: pointer;
  174.   LBIdx: Integer;
  175.   TgtModule: THandle;
  176.   Modl: TModuleEntry;
  177.   Tsk: TTaskEntry;
  178.   TermCount: Integer;
  179. begin
  180.   LBIdx := LB^.GetSelIndex;
  181.   if LBIdx < 0 then
  182.   begin
  183.     MessageBox(hWindow,'No module selected','Unload',MB_OK);
  184.     Exit;
  185.   end;
  186.   LB^.GetSelString(ModID,8);
  187.   MBInfo := @MODId;
  188.   WVSPrintF(MBStr, 'Unload %s, Are you sure?', MBInfo);
  189.   if MessageBox(hWindow,MBStr, 'Unload', mb_YesNo or
  190.     mb_IconQuestion) = id_Yes then
  191.   begin
  192.     { Remove the module from Windows}
  193.     Modl.dwSize := SizeOf(TModuleEntry);
  194.     Modl.szModule[0] := #0;
  195.     TgtModule := ModuleFindName(@Modl,ModID);
  196.     if TgtModule <> 0 then
  197.     begin
  198.       Tsk.dwSize := SizeOf(TTaskEntry);
  199.       TaskFirst(@Tsk);
  200.       TermCount := 0;
  201.       repeat
  202.         if Tsk.hModule = TgtModule then
  203.         begin
  204.           TerminateApp(Tsk.hTask,No_UAE_Box);
  205.           Inc(TermCount);
  206.         end;
  207.       until not TaskNext(@Tsk);
  208.       if TermCount = 0 then
  209.         { It's a DLL, so FreeLibrary it}
  210.         for TermCount := 1 to Modl.wUsageFlags do
  211.           FreeLibrary(TgtModule);
  212.     end;
  213.     LB^.DeleteString(LBIdx);
  214.     EndDlg(id_OK);
  215.   end;
  216. end;
  217.  
  218. procedure TModuleDlg.SetupWindow;
  219. var
  220.   Modl: TModuleEntry;
  221. begin
  222.   inherited SetupWindow;
  223.   Modl.dwSize := SizeOf(TModuleEntry);
  224.   if ModuleFirst(@Modl) then
  225.     repeat
  226.       LB^.AddString(Modl.szModule);
  227.     until not ModuleNext(@Modl);
  228.   LB^.SetSelIndex(0);
  229. end;
  230.  
  231. procedure TModuleDlg.Color;
  232. begin
  233.   {
  234.   if Msg.lParamHi = CTLCOLOR_LISTBOX then
  235.      begin
  236.      SetTextColor(Msg.wParam,$00800000);
  237.      SetBkMode(Msg.wParam,TRANSPARENT);
  238.      Msg.Result := GetStockObject(LTGRAY_BRUSH);
  239.      end
  240.   else
  241.   }
  242.   DefWndProc(Msg);
  243. end;
  244.  
  245. procedure TModuleDlg.OK;
  246. begin
  247.   LB^.GetSelString(ModuleName,8);
  248.   inherited OK(Msg);
  249. end;
  250.  
  251. procedure TModuleDlg.ModuleInfo;
  252. begin
  253.   LB^.GetSelString(ModuleName, 8);
  254.   Application^.ExecDialog(New(PModuleInfo,Init(@Self, 'MODINFO',
  255.     ModuleName)));
  256. end;
  257.  
  258. constructor TModuleInfo.Init;
  259. begin
  260.   Modl.dwSize := SizeOf(TModuleEntry);
  261.   Modl.szModule[0] := #0;
  262.   Module := ModuleFindName(@Modl, AModuleName);
  263.   if Module = 0 then Fail;
  264.   inherited Init(Aparent, AID, 0);
  265.   ModuleName := AModuleName;
  266. end;
  267.  
  268.  
  269. procedure TModuleInfo.WMCtlColor;
  270. begin
  271.   if Msg.lParamHi = ctlColor_Static then
  272.   begin
  273.     SetTextColor(Msg.wParam, $00800000);
  274.     SetBkMode(Msg.wParam, Opaque);
  275.     SetBKColor(Msg.wParam, $00FFFFFF);
  276.     Msg.Result := GetStockObject(ltGray_Brush);
  277.   end
  278.   else
  279.     DefWndProc(Msg);
  280. end;
  281.  
  282. procedure TModuleInfo.SetupWindow;
  283. var
  284.   Temp: array[0..20] of Char;
  285. begin
  286.   CodeSize := 0;
  287.   DataSize := 0;
  288.   ResourceSize := 0;
  289.   OtherSize := 0;
  290.   inherited SetupWindow;
  291.   Globl.dwSize := SizeOf(TGlobalEntry);
  292.   GlobalFirst(@Globl,GLOBAL_ALL);
  293.   repeat
  294.     with Globl do
  295.       if hOwner = Module then
  296.         case wType of
  297.           gt_Code:
  298.             Inc(CodeSize, dwBlockSize);
  299.           gt_Data, gt_DGroup, gt_Unknown:
  300.             Inc(DataSize, dwBlockSize);
  301.           gt_Resource:
  302.             Inc(ResourceSize, dwBlockSize);
  303.         else
  304.           Inc(OtherSize, dwBlockSize);
  305.         end;
  306.    until not GlobalNext(@Globl,GLOBAL_ALL);
  307.    SendDlgItemMsg(mi_ModName, wm_SetText, 0, LongInt(ModuleName));
  308.  
  309.    Str(CodeSize,Temp);
  310.    SendDlgItemMsg(mi_Code, wm_SetText, 0, LongInt(@Temp));
  311.  
  312.    Str(DataSize,Temp);
  313.    SendDlgItemMsg(mi_Data, wm_SetText, 0, LongInt(@Temp));
  314.  
  315.    Str(ResourceSize,Temp);
  316.    SendDlgItemMsg(mi_Resource, wm_SetText, 0, LongInt(@Temp));
  317.  
  318.    Str(OtherSize,Temp);
  319.    SendDlgItemMsg(mi_Other, wm_SetText, 0, LongInt(@Temp));
  320. end;
  321.  
  322. procedure TMemDlg.SetupWindow;
  323. var
  324.   MM: TMemManInfo;
  325.   CVA: array[0..30] of Char;
  326.  
  327.   function CVP(V: LongInt): LongInt;
  328.   var
  329.     Digits: Integer;
  330.     Commas: Integer;
  331.     NewIdx,CurIdx: Integer;
  332.   begin
  333.     FillChar(CVA, SizeOf(CVA), #0);
  334.     Str(V,CVA);
  335.     Digits := StrLen(CVA);
  336.     CurIdx := Pred(Digits);
  337.     if CVA[0] = '-' then Dec(Digits);
  338.     Commas := CurIdx div 3;
  339.     NewIdx := CurIdx + Commas;
  340.     Commas := 0;
  341.     while CurIdx >= 0 do
  342.     begin
  343.       if (commas = 3) and (CVA[CurIdx] <> '-') then
  344.       begin
  345.         commas := 0;
  346.         CVA[NewIdx] := ',';
  347.         Dec(NewIdx);
  348.       end;
  349.       CVA[NewIdx] := CVA[CurIdx];
  350.       Dec(CurIdx);
  351.       Dec(NewIdx);
  352.       inc(Commas);
  353.     end;
  354.     CVP := LongInt(@CVA);
  355.   end;
  356.  
  357. begin
  358.   inherited SetupWindow;
  359.   FillChar(MM,SizeOf(MM),0);
  360.   MM.dwSize := SizeOf(MM);
  361.   MemManInfo(@MM);
  362.   with MM do
  363.   begin
  364.     SendDlgItemMsg(101, wm_SetText, 0, CVP(dwLargestFreeBlock));
  365.     SendDlgItemMsg(102, wm_SetText, 0, CVP(dwMaxPagesAvailable));
  366.     SendDlgItemMsg(103, wm_SetText, 0, CVP(dwMaxPagesLockable));
  367.     SendDlgItemMsg(104, wm_SetText, 0, CVP(dwTotalLinearSpace));
  368.     SendDlgItemMsg(105, wm_SetText, 0, CVP(dwTotalUnlockedPages));
  369.     SendDlgItemMsg(106, wm_SetText, 0, CVP(dwFreePages));
  370.     SendDlgItemMsg(107, wm_SetText, 0, CVP(dwTotalPages));
  371.     SendDlgItemMsg(108, wm_SetText, 0, CVP(dwFreeLinearSpace));
  372.     SendDlgItemMsg(109, wm_SetText, 0, CVP(dwSwapFilePages));
  373.     SendDlgItemMsg(110, wm_SetText, 0, CVP(wPageSize));
  374.   end;
  375. end;
  376.  
  377. end.
  378.